home *** CD-ROM | disk | FTP | other *** search
/ TestDrive Windows 1993 Fall / TestDrive Windows 1993 Fall.iso / dbase / samples / goods.frg < prev    next >
Encoding:
Text File  |  1993-03-09  |  8.1 KB  |  404 lines
  1. * Program............: goods.FRG
  2. * Date...............: 3-09-93
  3. * Versions...........: dBASE IV, Report 2.0
  4. *
  5. * Notes:
  6. * ------
  7. * Prior to running this procedure with the DO command
  8. * it is necessary use LOCATE because the CONTINUE
  9. * statement is in the main loop.
  10. *
  11. *-- Parameters
  12. PARAMETERS gl_noeject, gl_plain, gl_summary, gc_heading, gc_extra
  13. ** The first three parameters are of type Logical.
  14. ** The fourth parameter is a string.  The fifth is extra.
  15. PRIVATE _peject, _wrap, ll_heading
  16. ll_heading = .F.
  17.  
  18. *-- Test for no records found
  19. IF EOF() .OR. .NOT. FOUND()
  20.    RETURN
  21. ENDIF
  22.  
  23. *-- turn word wrap mode off
  24. _wrap=.F.
  25.  
  26. IF _plength < (_pspacing * 3 + 1) + (_pspacing + 1) + 2
  27.    SET DEVICE TO SCREEN
  28.    DEFINE WINDOW gw_report FROM 7,17 TO 11,62 DOUBLE
  29.    ACTIVATE WINDOW gw_report
  30.    @ 0,1 SAY "Increase the page length for this report."
  31.    @ 2,1 SAY "Press any key ..."
  32.    x=INKEY(0)
  33.    DEACTIVATE WINDOW gw_report
  34.    RELEASE WINDOW gw_report
  35.    RETURN
  36. ENDIF
  37.  
  38. _plineno=0          && set lines to zero
  39. *-- NOEJECT parameter
  40. IF gl_noeject
  41.    IF _peject="BEFORE"
  42.       _peject="NONE"
  43.    ENDIF
  44.    IF _peject="BOTH"
  45.       _peject="AFTER"
  46.    ENDIF
  47. ENDIF
  48.  
  49. *-- Set-up environment
  50. ON ESCAPE DO Prnabort
  51. IF SET("TALK")="ON"
  52.    SET TALK OFF
  53.    gc_talk="ON"
  54. ELSE
  55.    gc_talk="OFF"
  56. ENDIF
  57. gc_space=SET("SPACE")
  58. SET SPACE OFF
  59. gc_time=TIME()      && system time for predefined field
  60. gd_date=DATE()      && system date  "    "    "     "
  61. gl_fandl=.F.        && first and last page flag
  62. gl_prntflg=.T.      && Continue printing flag
  63. gl_widow=.T.        && flag for checking widow bands
  64. gn_length=LEN(gc_heading)  && store length of the HEADING
  65. gn_level=2          && current band being processed
  66. gn_page=_pageno     && grab current page number
  67. gn_pspace=_pspacing && get current print spacing
  68.  
  69. *-- Initialize group footer field variables
  70. r_foot1=.F.
  71.  
  72. *-- Initialize calculated variables.
  73. inv_cost=0
  74.  
  75. *-- Set up procedure for page break
  76. gn_atline=_plength - (_pspacing + 1)
  77. ON PAGE AT LINE gn_atline EJECT PAGE
  78.  
  79. *-- Print Report
  80.  
  81. PRINTJOB
  82.  
  83. *-- Initialize group break vars.
  84. r_mvar4=VENDOR_ID
  85.  
  86. *-- Initialize summary variables.
  87. r_msum1=0
  88. r_msum2=0
  89.  
  90. *-- Assign initial values to calculated variables.
  91. inv_cost=QTY_ONHAND*COST
  92.  
  93. IF gl_plain
  94.    ON PAGE AT LINE gn_atline DO Pgplain
  95. ELSE
  96.    ON PAGE AT LINE gn_atline DO Pgfoot
  97. ENDIF
  98.  
  99. DO Pghead
  100.  
  101. gl_fandl=.T.        && first physical page started
  102.  
  103. DO Rintro
  104.  
  105. DO Grphead
  106.  
  107. *-- File Loop
  108. DO WHILE FOUND() .AND. .NOT. EOF() .AND. gl_prntflg
  109.    DO CASE
  110.    CASE VENDOR_ID <> r_mvar4
  111.       gn_level=4
  112.    OTHERWISE
  113.       gn_level=0
  114.    ENDCASE
  115.    *-- test whether an expression didn't match
  116.    IF gn_level <> 0
  117.       DO Grpfoot WITH 100-gn_level
  118.       DO Grpinit
  119.    ENDIF
  120.    *-- Repeat group intros
  121.    IF gn_level <> 0
  122.       DO Grphead
  123.    ENDIF
  124.    gn_level=0
  125.    *-- Detail lines
  126.    IF gl_summary
  127.       DO Upd_Vars
  128.    ELSE
  129.       DO __Detail
  130.    ENDIF
  131.    gl_widow=.T.         && enable widow checking
  132.    CONTINUE
  133. ENDDO
  134.  
  135. IF gl_prntflg
  136.    gn_level=3
  137.    DO Grpfoot WITH 97
  138.    DO Rsumm
  139.    IF _plineno <= gn_atline
  140.       EJECT PAGE
  141.    ENDIF
  142. ELSE
  143.    gn_level=3
  144.    DO Rsumm
  145.    DO Reset
  146.    RETURN
  147. ENDIF
  148.  
  149. ON PAGE
  150.  
  151. ENDPRINTJOB
  152.  
  153. DO Reset
  154. RETURN
  155. * EOP: goods.FRG
  156.  
  157. *-- Determine height of group bands and detail band for widow checking
  158. FUNCTION Gheight
  159. PARAMETER Group_Band
  160. retval=0              && return value
  161. IF Group_Band <= 4
  162.    retval = retval + 2 * gn_pspace
  163. ENDIF
  164. *-- add height of detail band
  165. retval = retval + 10 * gn_pspace
  166. RETURN retval
  167. * EOP: Gheight
  168.  
  169. *-- Update summary fields and/or calculated fields.
  170. PROCEDURE Upd_Vars
  171. inv_cost=QTY_ONHAND*COST
  172. r_foot1=Vendor_id
  173. *-- Sum
  174. r_msum1=r_msum1+INV_COST
  175. *-- Sum
  176. r_msum2=r_msum2+INV_COST
  177. RETURN
  178. * EOP: Upd_Vars
  179.  
  180. *-- Set flag to get out of DO WHILE loop when escape is pressed.
  181. PROCEDURE Prnabort
  182. gl_prntflg=.F.
  183. RETURN
  184. * EOP: Prnabort
  185.  
  186. *-- Reset group break variables.  Reinit summary
  187. *-- fields with reset set to a particular group band.
  188. PROCEDURE Grpinit
  189. IF gn_level <= 4
  190.    r_msum1=0
  191. ENDIF
  192. IF gn_level <= 4
  193.    r_mvar4=VENDOR_ID
  194. ENDIF
  195. RETURN
  196. * EOP: Grpinit
  197.  
  198. *-- Process Group Intro bands during group breaks
  199. PROCEDURE Grphead
  200. IF EOF()
  201.    RETURN
  202. ENDIF
  203. PRIVATE _pspacing
  204. _pspacing=gn_pspace
  205. IF gn_level = 0
  206.    gn_level=50
  207. ENDIF
  208. IF gn_level = 4
  209.    IF 2 * gn_pspace  < gn_atline
  210.       IF (gl_widow .AND. _plineno+Gheight(4) > gn_atline + 1) ;
  211.       .OR. (gl_widow .AND. _plineno+2 * gn_pspace > gn_atline)
  212.          EJECT PAGE
  213.       ENDIF
  214.    ENDIF
  215. ENDIF
  216. IF gn_level <= 4
  217.    DO Head4
  218. ENDIF
  219. gn_level=0
  220. RETURN
  221. * EOP: Grphead.PRG
  222.  
  223. *-- Process Group Summary bands during group breaks
  224. PROCEDURE Grpfoot
  225. PARAMETER ln_level
  226. IF ln_level >= 96
  227.    DO Foot96
  228. ENDIF
  229. RETURN
  230. * EOP: Grpfoot.PRG
  231.  
  232. PROCEDURE Pghead
  233. PRIVATE ll_heading, ln_width
  234. ll_heading = .T.
  235. ln_width = _rmargin - _lmargin
  236. ?
  237. *-- Print HEADING parameter - if it doesn't fit on line one
  238. *-- Value added to gn_length is the last column on line one times two
  239. IF .NOT. gl_plain .AND. gn_length + 160 > ln_width
  240.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width))
  241.    ?
  242.    ll_heading = .F.
  243. ENDIF
  244.  
  245. ?? IIF(gl_plain,'',gd_date) AT 0,;
  246.  IIF(gl_plain,'' , "PAGE  " ) AT 70,;
  247.  IIF(gl_plain,'',_pageno) PICTURE "999" 
  248.  
  249. *-- Print HEADING parameter - if it fits on line one
  250. IF .NOT. gl_plain .AND. gn_length > 0 .AND. ll_heading
  251.    ?? " "
  252.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width-(_pcolno*2)))
  253. ENDIF
  254. ?
  255. ?
  256. RETURN
  257. * EOP: Pghead
  258.  
  259. PROCEDURE Rintro
  260. ?
  261. DEFINE BOX FROM 27 TO 56 HEIGHT 4 DOUBLE
  262. ?
  263. ?? "A-T FURNITURE INDUSTRIES" AT 30
  264. ?
  265. ?? "INVENTORY REPORT" AT 34
  266. ?
  267. ?
  268. ?
  269. ?
  270. RETURN
  271. * EOP: Rintro
  272.  
  273. PROCEDURE Head4
  274. IF gn_level=1
  275.    RETURN
  276. ENDIF
  277. ?? ;
  278. "══════════════════════════════════════════════════════════════════════";
  279. + "═════════";
  280. AT 0
  281. ?
  282. ?? "VENDOR ID: " STYLE "BU" AT 0,;
  283.  Vendor_id FUNCTION "T" STYLE "BU" 
  284. ?
  285. RETURN
  286.  
  287. PROCEDURE __Detail
  288. IF 10 * gn_pspace < gn_atline - (_pspacing * 3 + 1)
  289.    IF gl_widow .AND. _plineno+10 * gn_pspace > gn_atline + 1
  290.       EJECT PAGE
  291.    ENDIF
  292. ENDIF
  293. DO Upd_Vars
  294. ?? ;
  295. "──────────────────────────────────────────────────────────────────────";
  296. + "─────────";
  297. AT 0
  298. ?
  299. ?? "PART I.D.: " AT 3,;
  300.  Part_id FUNCTION "T" ,;
  301.  "NAME: " AT 27,;
  302.  Part_name FUNCTION "T" AT 40
  303. ?
  304. ?? "DESCRIPTION: " AT 27,;
  305.  Descript FUNCTION "T" 
  306. ?
  307. ?? "QUANTITY ON HAND:   " AT 27,;
  308.  Qty_onhand PICTURE "9,999" ,;
  309.  "SALES PRICE: $ " AT 55,;
  310.  Price PICTURE "99,999.99" 
  311. ?
  312. ?? "COST: $ " AT 27,;
  313.  "  " AT 41,;
  314.  Cost PICTURE "99,999.99" ,;
  315.  "ORDER QTY(min):    " AT 55,;
  316.  Qty_2order PICTURE "9,999" 
  317. ?
  318. ?? " ==========" AT 41,;
  319.  "DATE ORDERED:   " AT 55,;
  320.  Date_order 
  321. ?
  322. ?? "INVENT. COST:$" AT 27,;
  323.  inv_cost PICTURE "999,999.99" AT 42,;
  324.  "DISCONTINUED: " AT 55,;
  325.  Discontinu PICTURE "Y" 
  326. ?
  327. ?? "COMMENTS: " AT 27,;
  328.  Comments FUNCTION "T" 
  329. ?
  330. ?
  331. ?
  332. RETURN
  333. * EOP: __Detail
  334.  
  335. PROCEDURE Foot96
  336. ?
  337. ?? "INVENTORY COST FOR VENDOR " AT 0,;
  338.  r_foot1 FUNCTION "T" ,;
  339.  ": $ " ,;
  340.  r_msum1 PICTURE "999,999.99" ,;
  341.  " " 
  342. ?
  343. RETURN
  344.  
  345. PROCEDURE Rsumm
  346. ?
  347. ?? ;
  348. "══════════════════════════════════════════════════════════════════════";
  349. + "═════════";
  350. AT 0
  351. ?
  352. ?? "TOTAL INVENTORY COST: " AT 0,;
  353.  "$ " AT 32,;
  354.  r_msum2 PICTURE "999,999.99" 
  355. ?
  356. ?? ;
  357. "══════════════════════════════════════════════════════════════════════";
  358. + "═════════";
  359. AT 0
  360. gl_fandl=.F.        && last page finished
  361. ?
  362. RETURN
  363. * EOP: Rsumm
  364.  
  365. PROCEDURE Pgfoot
  366. PRIVATE _box, _pspacing
  367. gl_widow=.F.         && disable widow checking
  368. _pspacing=1
  369. ?
  370. IF .NOT. gl_plain
  371.    _pspacing=gn_pspace
  372.    ?? "REPORT PREPARED BY FINANCIAL DEPARTMENT" AT 24
  373. ENDIF
  374. EJECT PAGE
  375. *-- is the page number greater than the ending page
  376. IF _pageno > _pepage
  377.    GOTO BOTTOM
  378.    SKIP
  379.    gn_level=0
  380. ENDIF
  381. IF .NOT. gl_plain .AND. gl_fandl
  382.    _pspacing=gn_pspace
  383.    DO Pghead
  384. ENDIF
  385. RETURN
  386. * EOP: Pgfoot
  387.  
  388. *-- Process page break when PLAIN option is used.
  389. PROCEDURE Pgplain
  390. PRIVATE _box
  391. EJECT PAGE
  392. RETURN
  393. * EOP: Pgplain
  394.  
  395. *-- Reset dBASE environment prior to calling report
  396. PROCEDURE Reset
  397. SET SPACE &gc_space.
  398. SET TALK &gc_talk.
  399. ON ESCAPE
  400. ON PAGE
  401. RETURN
  402. * EOP: Reset
  403.  
  404.